home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / fileinfo.scm < prev    next >
Text File  |  1995-10-28  |  4KB  |  116 lines
  1. ;;; Copyright (c) 1993, 1994 by Olin Shivers.
  2.  
  3. ;;; chase? true (the default) means if the file is a symlink, chase the link
  4. ;;; and report on the file it references. chase? = #f means check the actual
  5. ;;; file itself, even if it's a symlink.
  6. ;;; writeable means (1) file exists & is writeable OR (2) file doesn't exist
  7. ;;;     but directory is writeable.
  8.  
  9. ;;; Return values:
  10. ;;; #f            Accessible
  11. ;;; search-denied    Can't stat
  12. ;;; permission        File exists but is protected
  13. ;;;             (also for errno/rofs)
  14. ;;; no-directory    Some directory doesn't exist
  15. ;;; nonexistent        File itself doesn't exist
  16. ;;;
  17. ;;; Otherwise, signals an error.
  18.  
  19. (define (file-not-accessible? perms fd/port/fname . maybe-chase?)
  20.   (let ((uid (user-effective-uid)))
  21.     (and (not (zero? uid)) ; Root can do what he likes.
  22.      (with-errno-handler ((err data)
  23.                   ((errno/acces) 'search-denied)
  24.                   ((errno/noent) 'nonexistent)
  25.                   ((errno/notdir) 'not-directory))
  26.  
  27.        (and (let* ((info (apply file-info fd/port/fname maybe-chase?))
  28.                (acc (file-info:mode info)))
  29.           (cond ((= (file-info:uid info) (user-effective-uid)) ; User
  30.              (zero? (bitwise-and acc (arithmetic-shift perms 6))))
  31.               
  32.             ((= (file-info:gid info) (user-effective-gid)) ; Group
  33.              (zero? (bitwise-and acc (arithmetic-shift perms 3))))
  34.             ((memv (file-info:gid info) (user-supplementary-gids))
  35.              (zero? (bitwise-and acc (arithmetic-shift perms 3))))
  36.               
  37.             (else                    ; Other
  38.              (zero? (bitwise-and acc perms)))))
  39.         'permission)))))
  40.  
  41. ;;;;;;
  42.  
  43. (define (file-not-readable?   fd/port/fname)  (file-not-accessible? 4 fd/port/fname))
  44. (define (file-not-writable?   fd/port/fname)  (file-not-accessible? 2 fd/port/fname))
  45. (define (file-not-executable? fd/port/fname)  (file-not-accessible? 1 fd/port/fname))
  46.  
  47. (define (file-readable?   fd/port/fname)  (not (file-not-readable?   fd/port/fname)))
  48. (define (file-writable?   fd/port/fname)  (not (file-not-writable?   fd/port/fname)))
  49. (define (file-executable? fd/port/fname)  (not (file-not-executable? fd/port/fname)))
  50.  
  51. ;;; Spelling corrected.
  52. (define file-not-writeable?
  53.   (deprecated-proc file-not-writable? "file-not-writeable?"
  54.            "Use file-not-writable? instead"))
  55.  
  56. (define file-writeable?
  57.   (deprecated-proc file-writable? "file-writeable?"
  58.            "Use file-writable? instead"))
  59.  
  60. ;;;;;;
  61.  
  62. ;;; Returns
  63. ;;; #f           exists
  64. ;;; #t           doesn't exist
  65. ;;; 'search-denied can't stat
  66. ;;; ...or signals an error
  67.  
  68. (define (file-not-exists? fd/port/fname . maybe-chase?)
  69.   (with-errno-handler
  70.       ((err data)
  71.        ((errno/acces) 'search-denied)
  72.        ((errno/noent errno/notdir) #t))
  73.     (apply file-info fd/port/fname maybe-chase?)
  74.     #f))
  75.  
  76. (define (file-exists? fd/port/fname . maybe-chase?)
  77.   (not (apply file-not-exists? fd/port/fname maybe-chase?)))
  78.  
  79. ;;;;;;
  80.  
  81. ;;; stat and derived file-{mode,size,owner,group,times,inode,...} ops.
  82.  
  83. (define-simple-syntax (define-stat-proc proc info-slot)
  84.   (define (proc fname/fd/port . maybe-chase?)
  85.     (info-slot (apply file-info fname/fd/port maybe-chase?))))
  86.  
  87. (define-stat-proc file-type               file-info:type)
  88. (define-stat-proc file-group              file-info:gid)
  89. (define-stat-proc file-inode              file-info:inode)
  90. (define-stat-proc file-last-access        file-info:atime)
  91. (define-stat-proc file-last-mod           file-info:mtime)
  92. (define-stat-proc file-last-status-change file-info:ctime)
  93. (define-stat-proc file-mode               file-info:mode)
  94. (define-stat-proc file-nlinks             file-info:nlinks)
  95. (define-stat-proc file-owner              file-info:uid)
  96. (define-stat-proc file-size               file-info:size)
  97.  
  98. (define (file-directory? fname/fd/port . maybe-chase?)
  99.   (eq? 'directory (apply file-type fname/fd/port maybe-chase?)))
  100.  
  101. (define (file-fifo? fname/fd/port . maybe-chase?)
  102.   (eq? 'fifo (apply file-type fname/fd/port maybe-chase?)))
  103.  
  104. (define (file-regular? fname/fd/port . maybe-chase?)
  105.   (eq? 'regular (apply file-type fname/fd/port maybe-chase?)))
  106.  
  107. (define (file-socket? fname/fd/port . maybe-chase?)
  108.   (eq? 'socket (apply file-type fname/fd/port maybe-chase?)))
  109.  
  110. (define (file-special? fname/fd/port . maybe-chase?)
  111.   (let ((type (apply file-type fname/fd/port maybe-chase?)))
  112.     (or (eq? 'block-special type) (eq? 'char-special type))))
  113.  
  114. (define (file-symlink? fname/fd/port)  ; No MAYBE-CHASE?, of course.
  115.   (eq? 'symlink (file-type fname/fd/port #f)))
  116.